home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / MODULE < prev    next >
Encoding:
Text File  |  1992-06-01  |  14.8 KB  |  632 lines
  1. \  Mike Haas...(c) 1987 Mikes Software
  2. \
  3. \   The idea here is to load the includes and link them in early in the
  4. \ system generation so that a binary form of the includes may be preserved
  5. \ without always being present (and slowing up dictionary searches).
  6. \
  7. \   A 'module header' is created and used for management of a module, once it
  8. \ has been compiled and saved in module form.
  9. \
  10. \
  11. \ To create a module:
  12. \ 1. Declare it via:     MODULE MyIncludes  (create the initialized mod hdr).
  13. \ 2. Shift compilation to a split area with:
  14. \                        60 ( #k ) MAKEMODULE MyIncludes
  15. \    ( subsequent compiling goes to split area )
  16. \ 3. When done:          SEALMODULE MyIncludes
  17. \    This creates a file that you may, when it is not resident, get and link
  18. \    the module with     GETMODULE MyIncludes
  19. \    NOTE:  'GetModule' leaves the split area in thevocab search...you can
  20. \    'unhook' it till you need it (faster compiles) with:
  21. \                        HIDEMODULE MyIncludes
  22. \    and later 'rehook' it in with:
  23. \                        GETMODULE MyIncludes
  24. \ Note that a loaded module may be cpompletely detached (and freed) with:
  25. \                        DETACHMODULE MyIncludes
  26.  
  27. \ 06-07-88 mdh Added 'Hash-Damaged on' to appropriate places
  28. \ 00002 11-oct-91 mdh     Added CacheClearU() to GETMODULE
  29. \ 00003 1/22/92 mdh/plb  MODON needed HASH-DAMAGED after >LINK !
  30. \            Added HASH-DAMAGED ON to (UN)LinkModVoc
  31.  
  32. max-inline @   6 max-inline !  \ this NEVER has to be fast.
  33.  
  34. include? MODULE_BIT jf:sfa_bits
  35. include? :struct jf:c_struct
  36. include? Strip-Pathname jf:Strip-Pathname
  37.  
  38. ANEW TASK-MODULE
  39.  
  40.  
  41. decimal
  42.  
  43.  
  44. .NEED nfacount
  45.    : NFACOUNT  dup 1+ swap c@ $ 1f and ;
  46. .THEN
  47.  
  48.  
  49. variable UnSplitTo    variable UnSplitLatest    variable ModNameSet
  50.  
  51.  
  52. \ offsets to reference Module Header fields...
  53.  
  54. : M.LOADED    ( cfa -- addr ) [  0 do-does-size + ] literal  +   ;
  55. : M.ADDR      ( cfa -- addr ) [  4 do-does-size + ] literal  +   ;
  56. : M.VERSION   ( cfa -- addr ) [  8 do-does-size + ] literal  +   ;
  57.  
  58. ( 0, 4, 8, 12, 16 )
  59.  
  60. : M.VOCLINK   ( cfa -- addr ) [ 16 do-does-size + ] literal  +   ;
  61.  
  62. : M.SIZE      ( cfa -- addr ) [ 20 do-does-size + ] literal  +   ;
  63. : M.LATEST    ( cfa -- addr ) [ 24 do-does-size + ] literal  +   ;
  64. : M.PREVNFA   ( cfa -- addr ) [ 28 do-does-size + ] literal  +   ;
  65. : M.HIDDEN    ( cfa -- addr ) [ 32 do-does-size + ] literal  +   ;
  66.  
  67.  
  68. : MODULE  ( -- )  ( input: name )
  69.   create
  70.     0 ,                 ( module loaded flag )
  71.     0 ,                 ( current address )
  72.     0 ,  0 ,            ( 1 used as verification of compatibility )
  73.     0 ,                 ( mod-relative addr...voc-link for 1 <max> voc )
  74.     0 ,                 ( this modules #BYTES )
  75.     0 ,                 ( mod-relative addr...last nfa )
  76.     latest n>link @ ,   ( save my original lfa contents )
  77.     0 ,                 ( hidden flag )
  78.     last-sfa  ( -- sfa diff-to-here )  drop  dup @ MODULE_BIT or swap !
  79. ;
  80.  
  81.  
  82. : N>MODULE?  ( nfa -- flag )
  83.   name> 4 - @ MODULE_BIT and
  84. ;
  85.  
  86.  
  87. : ?MODULE  ( cfa -- cfa , quit if not )
  88.   dup >name n>Module? 0=
  89.   IF
  90.      ModNameSet off
  91.      >newline  ." ERROR:  " >name id.  ."  is NOT a MODULE!!!"  quit
  92.   THEN
  93. ;
  94.  
  95.  
  96. : pad100  pad 100 +
  97. ;
  98.  
  99.  
  100. : ModuleLatest  ( cfa -- adr-of-latest-nfa )
  101.   dup  M.ADDR @   swap M.LATEST @ +
  102. ;
  103.  
  104.  
  105. : GETVERSION  ( -- version# , add all addresses of NFAs )
  106.   0   [ ' :struct >name ] literal
  107.   BEGIN   n>link  @  ?dup
  108.   WHILE   ( -- sum nfa )   tuck + swap
  109.   REPEAT
  110. ;
  111.  
  112.  
  113. : MAKEMODULE  ( #k -- alloc & split, reflect in:  input: ModuleName )
  114.   ?exec  [compile] '  ?module    ( -- cfa )  >r
  115.   \
  116.   \ [ latest ] literal  0  r@   true  ( quit if in use )  MLOADED?
  117.   \
  118.   r@ M.LOADED @  ?ABORT" Can't MAKEMODULE; object in use."
  119.   1024 *
  120.   MEMF_CLEAR over allocblock?    ( -- size memadr )
  121.   dup  r@ M.ADDR !       ( -- size memadr )
  122.   here UnSplitTo !  latest UnSplitLatest !
  123.   dup  dp !  + dplimit !
  124.   r> drop
  125. ;
  126.  
  127. : GetModPath?   ( -- flag )
  128.   bl word  pad $move
  129.   here count Strip-Pathname  ( -- adr cnt )  here >$
  130.   here c@  pad c@  =   ( -- flag , 0=path specified )
  131.   skip-word? on
  132. ;
  133.  
  134. \ the data arrangement of the 1st cells in the file...
  135. \ cell 0,1   = version#
  136. \ cell 2     = possible rel-pointer to a voc's voc-link
  137. \ cell 3     = size in bytes of DATA AREA  (compiled code)
  138. \ cell 4     = module-relative address of last NFA
  139.  
  140. : SEALMODULE  ( -- , unsplit, update header & create file )
  141.               ( input: modulename )
  142.   ?exec
  143. \
  144.   GetModPath? ( -- flag )
  145. \
  146.   [compile] '
  147.   ?module   ( -- cfa )  >r
  148. \
  149. \ since SEAL only works after MAKE...
  150. \
  151.   r@ M.LOADED @    r@ M.ADDR @ 0=  or
  152.   IF
  153.      >newline [ latest ] literal id. ."  ERROR: need to MAKEMODULE first." quit
  154.   THEN
  155.   ( -- flag )
  156.   IF
  157.      \
  158.      \ create the file & update the module header...
  159.      \ create the file in 'mod:'...use NAME with .MOD appended...
  160.      \
  161.      " MOD:"  pad $move
  162.      r@ >name  dup 1+ swap c@ $ 1f and  pad  $append
  163.   THEN
  164.   " .MOD" count pad $append
  165.   pad new $fopen -dup 0=  ?ABORT" Can't open .MOD file for writing!"
  166.   ( -- file-pointer )  dup tempfile !  markfclose
  167. \
  168. \ open a file-virtual buffer...
  169. \
  170.   tempbuff OpenFV drop   ( addr stored in tempbuff... )
  171. \
  172. \ set the version...
  173. \
  174.   getversion  r@ M.VERSION !
  175. \
  176. \ size of code area...
  177. \
  178.   here  r@ M.ADDR @ -  ( -- #bytes )
  179.   r@ M.SIZE !
  180. \
  181. \ calc module-relative address of last NFA...
  182. \
  183.   latest  r@ M.ADDR @ -
  184.   r@ M.LATEST !
  185. \
  186. \ Do I contain a voc?
  187. \
  188.   VOC-LINK @  dup here <  swap r@ M.ADDR @ > and
  189.   IF
  190.      VOC-LINK @  r@ M.ADDR @ -
  191.   ELSE
  192.      0
  193.   THEN  r@ M.VOCLINK !
  194. \
  195. \ now save these 5 contigous cells to the file...
  196. \
  197.   r@ M.VERSION     5 0
  198.   DO
  199.      dup @ tempf,  cell+
  200.   LOOP
  201.   drop  ( -- )
  202. \
  203. \ now, UNRELOCATE the link-field contents in the area...
  204. \
  205.   r@ M.ADDR @ >r  \ save beginning address...
  206.   latest  ( -- nfa )  ( -r- modulecfa base-address )
  207.   BEGIN
  208.      dup r@ - 12 >
  209.   WHILE
  210.      n>link dup @  ( -- lfa nextnfa )  dup r@ -  ( -- lfa nxtnfa relnfa )
  211.      rot !
  212.   REPEAT  ( -- bottomnfa-in-mod ) n>link off
  213.   ( -- )  ( -r- modulecfa base-address )
  214. \
  215. \ If theres a VOC, UNrelocate its link-fields...
  216. \
  217.   1 rpick M.VOCLINK @
  218.   IF
  219.      VOC-LINK @ cell+   ( holds vocs latest )
  220.      BEGIN
  221.         ( -- lfa )  dup @ -dup
  222.      WHILE
  223.         ( -- lfa nfa )  dup r@ -  rot !  n>link
  224.      REPEAT  drop
  225.   THEN
  226. \
  227. \ save the data area to the file...
  228. \
  229.   r@
  230.   BEGIN
  231.      dup here <
  232.   WHILE
  233.      dup @ tempf,  cell+
  234.   REPEAT
  235.   drop    ( -- )  ( -r- modulecfa base-address )
  236. \
  237. \ and RE-RELOCATE the link-fields
  238. \
  239.   latest
  240.   BEGIN
  241.      dup r@ - 12 >
  242.   WHILE
  243.      n>link dup @  r@ +  ( -- lfa nextnfa )  dup rot !
  244.   REPEAT  ( lastnfa )
  245. \
  246. \ ... and any VOC lfas
  247. \
  248.   1 rpick M.VOCLINK @
  249.   IF
  250.      VOC-LINK @ cell+
  251.      BEGIN
  252.         ( -- lfa )  dup @ -dup
  253.      WHILE
  254.         ( -- lfa relnfa )  r@ +  dup rot !  n>link
  255.      REPEAT  drop
  256.   THEN
  257.   r> drop  ( -- last-nfa )
  258.   ( -r- modulecfa )  n>link  r@ >link dup @ rot !
  259.   ( -- modlfa )  latest swap !
  260.   UnSplitLatest @  current @ !
  261. \
  262. \ file is written, now close it...
  263. \
  264.   tempfile @  dup  tempbuff  closeFVWrite  dup unmarkfclose  fclose
  265. \
  266. \ mark it as loaded...
  267. \
  268.   true r@ M.LOADED !  r@ M.HIDDEN off
  269. \
  270. \ and unsplit the dictionary...
  271. \
  272.   UnSplitTo @ dp !
  273.   s0 @  dplimit !  
  274. \
  275.   rdrop
  276. ;
  277.  
  278. variable LMVfrm   variable LMVcnt
  279.  
  280. : LinkModVOC  ( MOD-CFA -- ) >r r@ M.VOCLINK @ -dup
  281.   IF
  282.      r@ M.ADDR @ +  
  283.      \
  284.      \ ( -- &voclink , link in to the VOCLINK chain & set up cold)
  285.      \
  286.      \ find the 1st voc in ColdVOCNFAs that is smaller...
  287.      #vocs @ cells 2*  LMVcnt !
  288.      ColdVOCNFAs       LMVfrm !
  289.      BEGIN
  290.         LMVfrm @ @   r@ <   LMVcnt @ 0= 0= and
  291.      WHILE
  292.         [ 2 cells ] literal  LMVfrm +!
  293.         [ 2 cells negate ] literal LMVcnt +!
  294.      REPEAT
  295.      LMVcnt @ 0=
  296.      IF
  297.         VOC-LINK @  over  ( -- mvl <VOC-LINK> mvl )  !
  298.         dup  VOC-LINK     ( -- mvl mvl VOC-LINK )  !
  299.         cell+ dup @ swap  ( -- <mvl+4> mvl+4 )
  300.         #vocs @ cells 2* ColdVOCNFAs +
  301.         swap over         ( -- <mvl+4> table mvl+4 table ) !
  302.         cell+             ( -- <mvl+4> table+4 )  !
  303.      ELSE
  304.         LMVfrm @  dup [ 2 cells ] literal +  LMVcnt @  move
  305.         LMVfrm @ @ cell- dup @ >r         ( save current <vl> )
  306.         over swap !   r> over !     ( -- mvl )
  307.         cell+ dup LMVfrm @ !
  308.         @ LMVfrm @ cell+ !
  309.      THEN
  310.      1 #vocs +!
  311.      hash-damaged on \ 00003
  312.   THEN rdrop
  313. ;
  314.  
  315. : UNLinkModVOC  ( mod-cfa -- )  >r  r@ M.VOCLINK @ -dup
  316.   IF
  317.      r@ M.ADDR @ +    ( -- &mvoclink )
  318.      >r  VOC-LINK
  319.      BEGIN
  320.         dup @         ( -- curlink nxtlink )
  321.         dup r@ =      ( -- curlink nxtlink modlink? )
  322.         swap 0= or 0= ( -- curlink not-modlink-or-0? )
  323.      WHILE
  324.         @             ( -- nxtlink )
  325.      REPEAT dup @     ( -- theL theL@ )
  326.      IF
  327.         \ It was found...
  328.         \
  329.         r@ @ over !
  330.         -1 #vocs +!   \ unlink the module
  331.         hash-damaged on \ 00003
  332.      THEN
  333.      drop  ( -- )  r> cell+  coldvocnfas  maxvocs 0
  334.      DO
  335.         2dup @ =
  336.         IF
  337.            dup dup 8 + swap  maxvocs i - 1-  8 *  move    leave
  338.         THEN  8 +
  339.      LOOP 2drop
  340.   THEN rdrop
  341. ;
  342.  
  343. : (GETMODULE)   ( modulecfa -- )
  344.   ?Module  >r
  345.   \
  346.   \ is it there already?
  347.   r@ M.LOADED @ 0=
  348.   IF
  349.      \
  350.      \ open the file?
  351.      ModNameSet @ 0=
  352.      IF
  353.         " MOD:" pad $move
  354.         r@ >name NFACount pad $append
  355.      THEN
  356.      ModNameSet off
  357.      " .MOD" count pad $append
  358.      pad  $fopen  -dup 0=
  359.      IF
  360.          >newline ." Can't open " pad $type  quit
  361.      THEN
  362.      dup tempfile !  dup markfclose
  363.      \
  364.      \ read in the 1st 20 bytes...
  365.      ( -- fp )  pad100  20 fread 20 -
  366.      IF
  367.          >newline  ." Error reading module "  pad $type  quit
  368.      THEN
  369.      \
  370.      \ check the version...
  371.      getversion  pad100 @   -
  372.      IF
  373.          >newline  pad $type  ."  is not compatible with this image!" quit
  374.      THEN
  375.      \
  376.      \ load module header with stuff...
  377.      pad100  8 +   r@ M.VOCLINK    [ 3 cells ] literal  move
  378.      \
  379.      \ allocate the memory...
  380.      MEMF_CLEAR  r@ M.SIZE @  dup >r  allocblock?   ( -- area )
  381.      dup  1 rpick M.ADDR  !          ( -- area )  ( -r- modcfa size )
  382.      \
  383.      \ load the binary...
  384.      tempfile @  swap  r@ fread r> -
  385.      IF
  386.          >newline pad $type ."  is not the expected size!"  quit
  387.      THEN     ( -- )   ( -r- modulecfa )
  388.      \
  389.      \ Relocate the link-fields, link it just before the module word...
  390.      \ the links are currently module-area relative...
  391.      \ calc module latest...
  392.      r@ ModuleLatest
  393.      r@ M.ADDR @ >r   ( -- latest-nfa )
  394.      dup  1 rpick  >link dup @ >r  !
  395.      ( -- latestmodnfa )  ( -r- modcfa baseadr nfa-before-modcfa )
  396.      BEGIN
  397.         n>link dup @ -dup
  398.      WHILE
  399.         ( -- lfa modrelnfa )  1 rpick +  dup rot !  ( -- nextnfa )
  400.      REPEAT
  401.      ( lfa )  r> swap !  ( -- )
  402.      \
  403.      \ ... and any VOC lfas
  404.      \
  405.      1 rpick M.VOCLINK @ -dup
  406.      IF
  407.         r@ + cell+
  408.         BEGIN
  409.            ( -- lfa )  dup @ -dup
  410.         WHILE
  411.            ( -- lfa relnfa )  r@ +  dup rot !  n>link
  412.         REPEAT  drop
  413.         1 rpick LinkMODVOC
  414.      THEN
  415.      r> drop   ( -r- modcfa )
  416.      \
  417.      \ mark it as loaded
  418.      true  r@ M.LOADED !
  419.      tempfile @ dup unmarkfclose fclose
  420.      Hash-Damaged on
  421.      CacheClearU()   \ 00002
  422.   ELSE
  423.      ModNameSet off
  424.      \
  425.      \ makesure its not bypassed...
  426.      r@ M.HIDDEN @
  427.      IF
  428.           r@ ModuleLatest  r@ >link !  Hash-Damaged on \ 00003
  429.           r@ LinkModVOC
  430.      THEN
  431.   THEN
  432.   r@ M.HIDDEN off
  433.   \
  434.   \ cleanup...
  435.   r> drop
  436. ;
  437.  
  438.  
  439. : GETMODULE  ( -- , make it resident if not there )  ( input: modulename )
  440.   \
  441.   \ get the cfa...
  442.   state @ >r  state off
  443.   GetModPath? 0= ModNameSet !
  444.   [compile] '    ( -- cfa )  r> state !   (GETMODULE)
  445. ;
  446.  
  447. : (HIDEMOD)  ( module-cfa -- )  ?module
  448.   \
  449.   dup M.HIDDEN @ 0=
  450.   IF
  451.      dup  M.PREVNFA @ over >link ! Hash-Damaged on \ 00003
  452.      dup  UnLinkModVOC  dup M.HIDDEN ON
  453.   THEN
  454.   drop
  455. ;
  456.  
  457. : HIDEMODULE  ( -- )   (  input:  modulename )
  458.   state @ >r  state off
  459.   [compile] '     ( -- cfa )  r> state !  >r
  460.   \
  461.   r@ M.LOADED @  r@ M.HIDDEN @ 0= and
  462.   IF
  463.      r@ (HideMod)
  464.   THEN
  465.   rdrop
  466. ;
  467.  
  468.  
  469. : (DETACHMOD)  ( cfa -- )  ?module
  470.   >r
  471.   r@ M.LOADED @
  472.   IF
  473.      r@ M.HIDDEN @ 0=
  474.      IF
  475.         r@ (HideMod)
  476.      THEN
  477.      r@ M.ADDR dup @  freeblock  off
  478.      r@ M.HIDDEN off  r@ M.LOADED off
  479.   THEN
  480.   rdrop
  481. ;
  482.  
  483. : DETACHMODULE  ( -- )   ( input:  modulename )
  484.   ?exec    [compile] '     ( -- cfa )   (DetachMod)
  485. ;
  486.   
  487.  
  488. : ExecModWord  ( nfa modulecfa -- , namne at here )  pad100 off
  489.   swap nfacount pad100 $append  pad100 swap >link (find)
  490.   IF
  491.      execute
  492.   ELSE
  493.      >newline ." Can't find " pad100 $type  quit
  494.   THEN
  495. ;
  496.  
  497.      
  498. : (WillCreate)  ( -- , name )
  499.   redef? @ >r   redef? off  [compile] :  r> redef? !
  500. ;
  501.  
  502.  
  503. : (Will) ( ifhide -- , <modulename> <wordname>  0=get ??=hide )
  504.   bl word find
  505.   IF
  506.      ?module
  507.      \
  508.      \ Module found...  ( -- what modulecfa )
  509.      \
  510.      2 x>r (WillCreate) 2 xr>  [compile] literal  ( -- what )   compile >r
  511.      compile r@  compile (GetModule)
  512.      latest [compile] literal  compile r@  compile ExecModWord
  513.      IF
  514.         compile r@  compile (HideMod)
  515.      THEN  compile rdrop    1 state !  [compile] ;
  516.   ELSE
  517.      0 error
  518.   THEN
  519. ;
  520.  
  521.  
  522. : WillHide ( -- , <modulename> <wordname> )
  523.   true (Will)
  524. ;
  525.  
  526.  
  527. : WillGet ( -- , <modulename> <wordname> )
  528.   false (Will)
  529. ;
  530.  
  531.  
  532. : ModOff  ( cfa -- )
  533.   ( -- cfa )  dup >r M.HIDDEN @
  534.   IF
  535.      ( -- )  r@ M.ADDR dup   @ r@ M.HIDDEN !   off
  536.   ELSE
  537.      r@ M.LOADED @  ( -- loaded? )
  538.      IF
  539.         r@ (HideMod)  r@ M.HIDDEN off
  540.      ELSE
  541.         r@ M.ADDR  off
  542.      THEN
  543.   THEN
  544.   r> M.LOADED off
  545. ;
  546.  
  547. : ModOn  ( cfa -- )
  548.   dup >r  M.ADDR @
  549.   IF
  550.       r@ M.LOADED on
  551.       r@ ModuleLatest  r@ >link !  Hash-Damaged on \ 00001
  552.       r@ LinkModVOC
  553.   ELSE
  554.       r@ M.HIDDEN @ ?dup
  555.       IF
  556.          r@ M.ADDR !  r@ M.LOADED on
  557.       THEN
  558.   THEN
  559.   rdrop
  560. ;
  561.  
  562. variable ModScanCFA
  563.  
  564. : Scan-Module  ( nfa -- )
  565.   ( -- nfa )  dup n>module?
  566.   IF
  567.      dup name> ModScanCFA @execute
  568.   THEN
  569.   drop
  570. ;
  571.  
  572.  
  573. : >Modules  ( cfa -- , execute on all defined modules )
  574.   modscancfa !
  575.   ' drop is when-voc-scanned
  576.   ' scan-module is when-scanned   scan-all-vocs
  577. ;
  578.  
  579.  
  580. redef? @  redef? off
  581.  
  582. : save-forth  ( -- , make all modules appear detached during the save )
  583.   only forth definitions
  584.   ' ModOFF  >Modules
  585. \ --------------------------------------------------------------
  586. \ empty ... M.ADDR = 0     M.LOADED = 0      M.HIDDEN = 0
  587. \ hidden... M.ADDR = 0     M.LOADED = 0      M.HIDDEN = baseaddr
  588. \ loaded... M.ADDR = addr  M.LOADED = 0      M.HIDDEN = 0
  589. \ --------------------------------------------------------------
  590.   save-forth
  591.   ' ModOn   >Modules
  592. ;
  593.  
  594. \ Set up new forget, called by FIND EXECUTE
  595. : [FORGET]  ( -- )
  596.   ' ModOFF  >Modules   [FORGET]   ' ModON  >Modules
  597. ;
  598.  
  599.  
  600. : DETACHMODULES  ( -- , detach ALL modules )
  601.   ' (DETACHMOD)  >Modules
  602. ;
  603.  
  604. : COLD  detachmodules cold  ;
  605.  
  606. redef? !
  607.  
  608. : .MOD  ( cfa -- , report status of module )
  609.   >newline  dup >name id.  space  ascii . 20 emit-to-column space
  610.   dup M.LOADED @
  611.   IF
  612.      dup M.HIDDEN @
  613.      IF
  614.         ." Hidden"
  615.      ELSE
  616.         ." Loaded"
  617.      THEN
  618.      bl 33 emit-to-column  ( cfa )  dup M.ADDR @ sizemem .(K)
  619.   ELSE
  620.      ." Detached"
  621.   THEN
  622.   drop  cr
  623. ;
  624.  
  625. : .Modules  ( -- , report status of ALL defined modules )
  626.   ' .MOD  >Modules
  627. ;
  628.  
  629.  
  630. max-inline !
  631.  
  632.